home *** CD-ROM | disk | FTP | other *** search
/ Delphi 2.0 - Programmer's Utilities Power Pack / Delphi 2.0 Programmer's Utilities Power Pack.iso / s_to_z / tpack / errormsg.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-09-15  |  5.3 KB  |  202 lines
  1. unit ErrorMsg;
  2.  
  3. interface
  4.  
  5. uses WinTypes, WinProcs, Classes, Graphics, Forms, Controls, Buttons,
  6.   StdCtrls, ExtCtrls, SysUtils, db, Dialogs
  7. , PasUtils
  8. , UserInfo;
  9.  
  10. type
  11.   TErrorDialogForm = class(TForm)
  12.     Memo1: TMemo;
  13.     OKBtn: TBitBtn;
  14.     CancelBtn: TBitBtn;
  15.     HelpBtn: TBitBtn;
  16.   private
  17.     { Private declarations }
  18.     procedure DecodeError(Error:Exception);
  19.   public
  20.     { Public declarations }
  21.   end;
  22.  
  23. {------------------------------------------------------------------------------}
  24. {                                                                              }
  25. {------------------------------------------------------------------------------}
  26.  
  27.   TErrorDialog = class(TDialogShell)
  28.     Error:Exception;
  29.     eSender: TObject;
  30.   private
  31.     fResult: TExceptionReAction;
  32.     fCanRetry: Boolean; {can an exception be retried?}
  33.     fCanIgnore: Boolean; {can an exception be ignored?}
  34.   protected
  35.     function GetTest:Boolean; override;
  36.     procedure SetTest(Value:Boolean); override;
  37.   public
  38.     constructor Create(aOwner:Tcomponent); override;
  39.     procedure ExceptionProc(Sender: TObject;E:Exception);
  40.     procedure RetryException(Sender:TObject;E:Exception;var Action:TExceptionReAction);
  41.     procedure Execute; Override;
  42.   published
  43.     property CanRetry: Boolean read fCanRetry write fCanRetry;
  44.     property CanIgnore: Boolean read fCanIgnore write fCanIgnore;
  45.     property Result: TExceptionReAction read fResult write fResult;
  46.     end;
  47.  
  48. {------------------------------------------------------------------------------}
  49. {                                                                              }
  50. {------------------------------------------------------------------------------}
  51.  
  52. implementation
  53.  
  54. {$R *.DFM}
  55.  
  56. {------------------------------------------------------------------------------}
  57. {                                                                              }
  58. {------------------------------------------------------------------------------}
  59.  
  60. constructor TErrorDialog.Create(aOwner:TComponent);
  61. begin
  62.   inherited Create(aOwner);
  63.   Error:=nil;
  64.   eSender:=nil;
  65.  
  66. {  Application.OnException:=ExceptionProc; } {ok but can be tricky!}
  67.  
  68. end;
  69.  
  70.  
  71. procedure TErrorDialog.ExceptionProc(Sender: TObject;E:Exception);
  72. begin
  73.   messagebeep($FFFF);
  74.   Error:=E;
  75.   eSender:=Self;
  76.   Screen.Cursor:=crDefault;
  77.   Execute;
  78. {  Application.ShowException(E); }
  79. end;
  80.  
  81.  
  82. procedure TErrorDialog.SetTest(Value:Boolean);
  83. begin
  84.   Error:=Exception.Create('Test of '+Classname);
  85.   eSender:=Self;
  86.   Execute;
  87.   Error.Free;
  88.   Error:=nil;
  89. end;
  90.  
  91. function TErrorDialog.GetTest:Boolean;
  92. begin
  93.   Result:=(fResult=reRetry);
  94. end;
  95.  
  96.  
  97. {------------------------------------------------------------------------------}
  98.  
  99. procedure TErrorDialog.RetryException(Sender:TObject;E:Exception;var Action:TExceptionReAction);
  100. begin
  101.   eSender:=Sender;
  102.   Error:=E;
  103.   fResult:=Action;
  104.   Execute;
  105.   Action:=fResult;
  106. end;
  107.  
  108.  
  109. procedure TErrorDialog.Execute;
  110. var
  111.   a:string;
  112.   b:TMsgDlgButtons;
  113.   Cursor:TCursor;
  114. begin
  115.   Cursor:=Screen.Cursor;
  116.   Screen.Cursor:=crDefault;
  117.  
  118.   if fCanIgnore and fCanRetry then
  119.     b:=mbAbortRetryIgnore
  120.   else
  121.     if fCanIgnore then
  122.       b:=[mbIgnore,mbCancel]
  123.     else
  124.       if fCanRetry then
  125.         b:=[mbRetry,mbCancel]
  126.       else
  127.         b:=[mbCancel];
  128.   case MessageDlg(Error.ClassName+'! in '+eSender.ClassName+#13+Error.Message, mtError,b,0) of
  129.     mrOk,
  130.     mrRetry: fResult:=reRetry;
  131.     mrIgnore: fResult:=reIgnore;
  132.     else
  133.       fResult:=reRaise;
  134.     end;
  135.  
  136. {  With TErrorDialogForm.Create(Application) do begin
  137.     if eSender<>nil then
  138.       Caption:=eSender.ClassName+' Dialog';
  139.     DecodeError(Error);
  140.     if ShowModal = IdOk then
  141.       fResult:= reRetry
  142.     else
  143.       fResult:= reRaise;
  144.     Free;
  145.     end;  }
  146.  
  147.   Screen.Cursor:=Cursor;
  148. end;
  149.  
  150. {------------------------------------------------------------------------------}
  151. {                                                                              }
  152. {------------------------------------------------------------------------------}
  153.  
  154. procedure TErrorDialogForm.DecodeError(Error:Exception);
  155. var
  156.   i,n:integer;
  157.   plural:boolean;
  158.   a:string[3];
  159. begin
  160.   if Error = nil then begin
  161.     Memo1.Text:='';
  162.     exit;
  163.     end;
  164.   plural:=false;
  165.   if Error is EdbEngineError then
  166.     with Error as EdbEngineError do begin
  167.       n:=ErrorCount;
  168.       plural:= n>1;
  169.       Memo1.Text:='Received '+inttostr(n)+' Error';
  170.       if plural then
  171.         Memo1.Text:=Memo1.Text+'s';
  172.       Memo1.Text:=Memo1.Text+' from the Database Engine that';
  173.       end
  174.   else
  175.     if Error is EdbEngineError then
  176.       Memo1.Text:='The Database Access layer reports an error that'
  177.     else
  178.       Memo1.Text:='An Error';
  179.  
  180.   if plural then
  181.     a:='are'
  182.   else
  183.     a:='is';
  184.   Memo1.Text:=Memo1.Text+' '+a+' detailed below. Please decide how to proceed.';
  185.   Memo1.Lines.Add(' ');
  186.  
  187.   if Error is EdbEngineError then
  188.     with Error as EdbEngineError do begin
  189.       for i:=0 to n-1 do
  190.         Memo1.Lines.Add(
  191.           inttostr(i+1)+'/'+inttostr(n)+': '
  192.           +'#'+inttostr(Errors[i].ErrorCode)+': '
  193.           +Errors[i].Message);
  194.       end
  195.   else
  196.     Memo1.Text:=Memo1.Text+' '+Error.ClassName+': '+Error.Message+'.';
  197. end;
  198.  
  199. {------------------------------------------------------------------------------}
  200.  
  201. end.
  202.